home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / CorePackages / aeom.tcl < prev    next >
Encoding:
Text File  |  2001-02-07  |  24.8 KB  |  763 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  TclAE - AppleEvent extension for Tcl
  4.  # 
  5.  #  FILE: "aeom.tcl"
  6.  #                                    created: 11/15/2000 {5:54:56 PM} 
  7.  #                                last update: 2/7/2001 {10:03:25 AM} 
  8.  #  Author: Jonathan Guyer
  9.  #  E-mail: jguyer@his.com
  10.  #    mail: POMODORO no seisan
  11.  #     www: http://www.his.com/jguyer/
  12.  #  
  13.  # ========================================================================
  14.  #               Copyright © 2000 Jonathan Guyer
  15.  #                      All rights reserved
  16.  # ========================================================================
  17.  # Permission to use, copy, modify, and distribute this software and its
  18.  # documentation for any purpose and without fee is hereby granted,
  19.  # provided that the above copyright notice appear in all copies and that
  20.  # both that the copyright notice and warranty disclaimer appear in
  21.  # supporting documentation.
  22.  # 
  23.  # Jonathan Guyer disclaims all warranties with regard to this software,
  24.  # including all implied warranties of merchantability and fitness.  In
  25.  # no event shall Jonathan Guyer be liable for any special, indirect or
  26.  # consequential damages or any damages whatsoever resulting from loss of
  27.  # use, data or profits, whether in an action of contract, negligence or
  28.  # other tortuous action, arising out of or in connection with the use or
  29.  # performance of this software.
  30.  # ========================================================================
  31.  #  Description: 
  32.  #  
  33.  #  Implementation of Alpha's AppleEvent Object Model.
  34.  # 
  35.  #  History
  36.  # 
  37.  #  modified   by  rev reason
  38.  #  ---------- --- --- -----------
  39.  #  2000-11-15 JEG 1.0 original
  40.  # ###################################################################
  41.  ##
  42.  
  43. alpha::extension aeom 1.0a2 {
  44.     alpha::package require tclAE
  45.     
  46.     if {[info tclversion] >= 8.0
  47.     &&    ![catch {namespace eval :: {package require tclAE}}]} {
  48.         aeom::defineAlpha7CommandsForTclAE
  49.     } else {
  50.         aeom::defineTclAECommandsForAlpha7
  51.     }
  52.     
  53.     if {![catch {alpha::package require Alpha 8.0d17}]} {
  54.         aeom::accessor::registerAll
  55.     } 
  56. } maintainer {
  57.     "Jon Guyer" <jguyer@his.com> <http://www.his.com/jguyer/>
  58. } help {
  59.     Implementation of Alpha's AppleEvent Object Model.  This
  60.     package is necessary for Alpha to work properly.
  61. }
  62.  
  63.  
  64. namespace eval aeom {}
  65.  
  66. # ◊◊◊◊ initialization ◊◊◊◊ #
  67.  
  68. proc aeom::_complainNoAE {} {
  69.     global HOME
  70.     alertnote "There appears to be no mechanism for sending \
  71.       AppleEvents.  Alpha will not be able to communicate with \
  72.       other applications unless TclAE.shlb is placed in ${HOME}: or \
  73.       in :Tool Command Language:."   
  74. }
  75.  
  76. proc aeom::defineAlpha7CommandsForTclAE {} {
  77.     
  78.     if {[llength [info commands "::tclAE::send"]] == 0} {
  79.         aeom::_complainNoAE
  80.     } else {
  81.         
  82.         if {[llength [info commands "::AEBuild"]] == 0} {
  83.             # AEBuild has been removed in Alpha 8, but needs to exist for
  84.             # legacy code. Patch it through to tclAE::send.
  85.             
  86.             ;proc ::AEBuild {args} {
  87.                 # AEBuild expects an AEGizmos AEPrint string
  88.                 eval tclAE::send -p $args
  89.             }
  90.         }
  91.         
  92.         if {[llength [info commands "::dosc"]] == 0} {
  93.             # dosc has been removed in Alpha 8, but needs to exist for
  94.             # legacy code. Patch it through to tclAE::send.
  95.             ;proc ::dosc {args} {
  96.                 set opts(-k) "'misc'"
  97.                 set opts(-e) "'dosc'"
  98.                 
  99.                 set opts(-t) 0
  100.                 set opts(-r) 0
  101.                 set opts(-q) 0
  102.                 
  103.                 getOpts {c n k e s f t}
  104.                 
  105.                 set dosc {tclAE::send}
  106.                 
  107.                 # set reply form
  108.                 if {$opts(-q)} {
  109.                     # queue
  110.                     set dosc {tclAE::send -q}
  111.                 } elseif {!$opts(-r)} {
  112.                     # directly (-r is backwards)
  113.                     set dosc {tclAE::build::resultData}
  114.                     
  115.                     if {$opts(-t) > 0} {
  116.                         # set timeout
  117.                         lappend dosc -t $opts(-t)
  118.                     }
  119.                 } else {
  120.                     set dosc {tclAE::send}
  121.                 }
  122.                 
  123.                 # set target
  124.                 if {[info exists opts(-c)]} {
  125.                     # by creator
  126.                     lappend dosc $opts(-c)
  127.                 } elseif {[info exists opts(-n)]} {
  128.                     # by name
  129.                     lappend dosc $opts(-n)
  130.                 } else {
  131.                     # prompt user
  132.                     set target [tclAE::PPCBrowser]
  133.                 }
  134.                 
  135.                 regexp {^'([^']*)'$} $opts(-k) blah class
  136.                 lappend dosc $class
  137.                 
  138.                 regexp {^'([^']*)'$} $opts(-e) blah event
  139.                 lappend dosc $event
  140.                 
  141.                 if {[info exists opts(-s)]} {
  142.                     lappend dosc ---- [tclAE::build::TEXT $opts(-s)]
  143.                 } elseif {[info exists opts(-f)]} {
  144.                     lappend dosc ---- [tclAE::build::alis $opts(-f)]
  145.                 } else {
  146.                     error "You must supply either a script or a file path"
  147.                 }
  148.                 
  149.                 set result [eval $dosc]
  150.             }
  151.         }
  152.     }        
  153.     
  154.     
  155.     # In Alpha 8, this is an internal command, so it will
  156.     # already exist. Earlier Alphas need to have the proc created here.
  157.     if {[llength [info commands "::tclAE::installEventHandler"]] == 0} {
  158.         aeom::_complainNoAE
  159.     } else {
  160.         if {[llength [info commands "::eventHandler"]] == 0} {
  161.             # eventHandler has been removed in Alpha 8, but needs to exist for
  162.             # legacy code. Patch it through to tclAE::installEventHander.
  163.             
  164.             ;proc ::eventHandler {args} {
  165.                 eval tclAE::installEventHandler $args
  166.             }
  167.         }
  168.     }
  169.     
  170.     tclAE::installEventHandler aevt oapp aeom::handleOpenApp
  171.     tclAE::installEventHandler aevt odoc aeom::handleOpen
  172.     tclAE::installEventHandler aevt pdoc aeom::handlePrint
  173.     tclAE::installEventHandler aevt quit aeom::handleQuit
  174.     
  175.     tclAE::installEventHandler misc dosc aeom::handleDoScript
  176.     
  177.     tclAE::aete::register aeom::constructAETE
  178.     
  179. #     resumeHandlingAppleEvents
  180. }
  181.  
  182.  
  183. proc aeom::defineTclAECommandsForAlpha7 {} {
  184.     alpha::package require binary
  185.     
  186.     # In Alpha 8, this is an internal command, so it will
  187.     # already exist. Earlier Alpha's need to have the proc created here.
  188.     if {[llength [info commands "tclAE::send"]] == 0} {
  189.         if {[llength [info commands "AEBuild"]] > 0} {
  190.             
  191.             # -r: direct reply requested
  192.             # -Q <proc>: queued reply requested (handler proc specified directly)
  193.             # -q: queued reply requested (register handler with currentReplyHandler)
  194.             # -p: print reply with AEPrint before returning it (if absent, return parsed AEDesc identifier).
  195.             # -t <timeout>: specifies event timeout in ticks
  196.             ;proc tclAE::send {args} {
  197.         global tclAE::directQueueHandlers
  198.                 
  199.                 set opts(-r) 0
  200.                 set opts(-q) 0
  201.                 set opts(-p) 0
  202.                 
  203.                 getOpts {t Q}
  204.                 
  205.                 set send {AEBuild}
  206.                 
  207.                 # set reply form
  208.                 if {[info exists opts(-Q)]} {
  209.                     # queue
  210.                     # this isn't quite right. 
  211.                     # <proc> is expecting TclAE descriptors, 
  212.                     # but replyHandler will give it AEGizmos.
  213.                     currentReplyHandler tclAE::directQueueHandler 1
  214.             lappend tclAE::directQueueHandlers $opts(-Q)
  215.                     lappend send -q
  216.                     unset opts(-Q)
  217.                 }
  218.                 
  219.                 if {[info exists opts(-t)]} {
  220.                     lappend send -t $opts(-t)
  221.                     unset opts(-t)
  222.                 }
  223.                 
  224.                 if {$opts(-r)} {
  225.                     lappend send -r
  226.                 } elseif {$opts(-q)} {
  227.                     lappend send -q
  228.                 } elseif {$opts(-p)} {
  229.                     lappend send -p
  230.                 }
  231.                 
  232.                 set event [eval [concat $send $args]]
  233.                 
  234.                 if {$opts(-p)} {
  235.                     return $event
  236.                 } elseif {$opts(-r)} {
  237.                     return [tclAE::parse::event $event]
  238.                 } else {
  239.                     return
  240.                 }                
  241.             }
  242.         
  243.         proc tclAE::directQueueHandler {queue} {
  244.         global tclAE::directQueueHandlers
  245.         
  246.         # Something's goofy with the
  247.         # form of queue as returned by AEPrint
  248.         regsub -all {\\\{} $queue "{" queue
  249.         regsub -all {\\\}} $queue "}" queue
  250.         
  251.         # parse the event and display any errors
  252.         set queueDesc [tclAE::parse::event $queue]
  253.         set dummyDesc [tclAE::createDesc null]
  254.         
  255.         set handled 0
  256.         foreach handler ${tclAE::directQueueHandlers} {
  257.             if {![catch {$handler $queueDesc $dummyDesc}]} {
  258.                 set tclAE::directQueueHandlers \
  259.               [lremove ${tclAE::directQueueHandlers} $handler]
  260.             set handled 1
  261.             } 
  262.         } 
  263.         
  264.         tclAE::disposeDesc $queueDesc
  265.         tclAE::disposeDesc $dummyDesc
  266.         return $handled
  267.         }
  268.         } else {
  269.             aeom::_complainNoAE
  270.         }        
  271.     }
  272.     
  273.     
  274.     # In Alpha 8, this is an internal command, so it will
  275.     # already exist. Earlier Alpha's need to have the proc created here.
  276.     if {[llength [info commands "tclAE::installEventHandler"]] == 0} {
  277.         if {[llength [info commands "eventHandler"]] > 0} {
  278.             ;namespace eval tclAE {}
  279.             
  280.             ;proc tclAE::installEventHandler {args} {
  281.                 eval eventHandler $args
  282.             }
  283.         } else {
  284.             aeom::_complainNoAE
  285.         }        
  286.     }
  287.     
  288.     # tclAE::target only exists in Alpha 8
  289.     if {[llength [info commands "tclAE::target"]] == 0} {
  290.         if {[cache::exists tclAETargets]} {
  291.             message "Restoring AE Targets…"
  292.             
  293.             cache::read tclAETargets
  294.             foreach targetArray [info locals target*] {
  295.                 # Need to write target set commands
  296.                 
  297.                 set target [set ${targetArray}(hashKey)]
  298.                 unset ${targetArray}(hashKey)
  299.                 foreach keyword [array names $targetArray] {
  300.                     # Copy target information into internal hash table
  301.                     tclAE::target set $target $keyword \
  302.                       [set ${targetArray}($keyword)]
  303.                 }
  304.                 
  305.                 # We probably don't really need to do this, since it's local
  306.                 unset $targetArray
  307.             }    
  308.         } 
  309.     }   
  310. }
  311.  
  312. # ◊◊◊◊ Required AppleEvent Handlers ◊◊◊◊ #
  313.  
  314. proc aeom::handleOpenApp {theAppleEvent theReplyAE} {
  315.     
  316. }
  317.  
  318. proc aeom::handleQuit {theAppleEvent theReplyAE} {
  319. #     alertnote [tclAE::print $theReplyAE]
  320.     quit
  321. }
  322.         
  323. proc aeom::handlePrint {theAppleEvent theReplyAE} {
  324.     
  325.     set theAESubDesc [tclAE::subdesc::fromDesc $theAppleEvent]
  326.     tclAE::subdesc::getKey $theAESubDesc ---- 1
  327.     set paths [aeom::_extractPaths $theAESubDesc]
  328.     tclAE::subdesc::dispose $theAESubDesc
  329.     
  330.     foreach path $paths {
  331.         set winNum [lsearch -exact [winNames -f] $path]
  332.         if { $winNum < 0 } {
  333.             set winNum [lsearch [winNames -f] "[quote::Glob $path] <*>"]
  334.         }
  335.         
  336.         edit -c $path
  337.         catch {::print}
  338.         
  339.         if {$winNum < 0} {
  340.             # Window was only opened for the print command
  341.             killWindow
  342.         }
  343.     }
  344. }
  345.  
  346. proc aeom::handleOpen {theAppleEvent theReplyAE} {
  347.     set theAESubDesc [tclAE::subdesc::fromDesc $theAppleEvent]
  348.     tclAE::subdesc::getKey $theAESubDesc ---- 1
  349.     set paths [aeom::_extractPaths $theAESubDesc]
  350.     tclAE::subdesc::dispose $theAESubDesc
  351.     
  352.     if {[catch {tclAE::getKeyData $theAppleEvent perm} allWritable]} {
  353.         set allWritable "yes "
  354.     }
  355.     if {[catch {tclAE::getKeyData $theAppleEvent Wrap} allWrapped]} {
  356.         set allWrapped "no  "
  357.     }
  358.     if {[catch {tclAE::getKeyData $theAppleEvent NewW} allNewWins]} {
  359.         set allNewWins "no  "
  360.     }
  361.     # horrible, Horrible, HORRIBLE position specifier
  362.     # designed by THINK, but used by OzTeX (maybe others?)
  363.     if {![catch {tclAE::getKeyData $theAppleEvent kpos ????} THINKPosInfo]} {
  364.         binary scan $THINKPosInfo SSIIII THINKshowMsg THINKline THINKstart THINKend THINKerrmsgH THINKfileModDate
  365.         
  366.         set gotTHINKposition 1
  367.     } else {
  368.         set gotTHINKposition 0
  369.     }
  370.     
  371.     foreach path $paths {
  372.         set parameters {}
  373.         
  374.         set wrapit $allWrapped
  375.         set writable $allWritable
  376.         set newWin $allNewWins
  377.         
  378.         set windows [winNames -fnocount]
  379.         set winNum [lsearch -exact $windows $path]
  380.         
  381.         if {$winNum >= 0
  382.         &&    $newWin == "ask "} {
  383.             if {[askyesno "Do you want another copy of ‘[file tail $path]’?"] == "yes"} {
  384.                 set newWin "yes "
  385.             } else {
  386.                 set newWin "no  "
  387.             }
  388.         }
  389.         
  390.         if {$winNum >= 0
  391.         &&    $newWin == "no  "} { 
  392.             bringToFront [lindex $windows $winNum]
  393.             unset writable
  394.             unset wrapit
  395.         } else {
  396.             openFile $path
  397.             
  398.             getWinInfo flags
  399.             
  400.             if {${flags(hasSpurious)}
  401.             &&    $writable == "ask "} {
  402.                 set lockit [alert -t stop -k "Lock File" -c "Allow Save" -o "" \
  403.                   "The file ‘[file tail $path]’ had inconsistent line terminations. \
  404.                   They have been converted to Carriage Returns." \
  405.                   "Saving this file may damage it if it was binary data."]
  406.                 
  407.                 if {$lockit == "Lock File"} {
  408.                     set writable "no  "
  409.                 } else {
  410.                     set writable "yes "
  411.                 }
  412.             }
  413.             
  414.             if {$writable == "no  "} {
  415.                 setWinInfo read-only 1
  416.                 unset wrapit
  417.             } else {
  418.                 if {${flags(needsWrap)}
  419.                 &&    $wrapit == "ask "} {
  420.                     set doWrap [alert -t caution -k "Wrap It" -c "Leave It Alone" -o "" \
  421.                       "Wrap ‘[file tail $path]’?" \
  422.                       "This will remove the paragraph formatting from the file."]
  423.                     
  424.                     if {$doWrap == "Wrap It"} {
  425.                         set wrapit "yes "
  426.                     } else {
  427.                         set wrapit "no  "
  428.                     }
  429.                 }
  430.                 
  431.                 if {${flags(needsWrap)}
  432.                 &&    $wrapit == "yes "} {
  433.                     set savePos [getPos]
  434.                     wrapText [minPos] [maxPos]
  435.                     goto $savePos
  436.                     setWinInfo needsWrap 0
  437.                 }
  438.             }
  439.         }
  440.         
  441.         if {$gotTHINKposition} {
  442.             if {$THINKline >= 0} {
  443.                 set minRowCol [posToRowCol [minPos]]
  444.                 incr THINKline [lindex $minRowCol 0]
  445.                 goto [rowColToPos $THINKline 0]
  446.                 nextLineSelect
  447.                 centerRedraw
  448.                 
  449.                 if {$THINKshowMsg} {
  450.                     alert -t stop -c "" -o "" "@#*!% THINK error" \
  451.                       [format "Error message handle address 0x%08X" $THINKerrmsgH]
  452.                 } 
  453.             } else {
  454.                 select $THINKstart $THINKend
  455.                 centerRedraw
  456.             }
  457.         } 
  458.         
  459.         
  460.         if {[info exists newWin]} {
  461.             lappend parameters NewW $newWin
  462.         }
  463.         if {[info exists writable]} {
  464.             lappend parameters perm $writable
  465.         }
  466.         if {[info exists wrapit]} {
  467.             lappend parameters Wrap $wrapit
  468.         }
  469.         
  470.         lappend sortedPaths(${parameters}) $path
  471.         
  472.     }
  473.     
  474.     # if kAEDirectCall
  475.     # for recording purposes only
  476.     if {[tclAE::getAttributeData $theAppleEvent esrc] == 1} { 
  477.         foreach condition [array names sortedPaths] {
  478.             set pathList [tclAE::createList]
  479.             foreach path [set sortedPaths($condition)] {
  480.                 tclAE::putDesc $pathList -1 [tclAE::build::alis $path]
  481.             }
  482.             eval tclAE::send -s -dx aevt odoc ---- $pathList $condition
  483.             tclAE::disposeDesc $pathList
  484.         }
  485.     } 
  486.     
  487.     return
  488. }
  489.  
  490.  
  491. proc aeom::handleAnswer {theAppleEvent theReplyAE} {
  492.     if {![catch {tclAE::getKey $theAppleEvent CERR} errorList]} {
  493.         think::parseCompileErrors $errorList
  494.     } else {
  495.         handleReply [tclAE::print $theAppleEvent]
  496.     }    
  497. }
  498.  
  499. ## 
  500.  # -------------------------------------------------------------------------
  501.  # 
  502.  # "aeom::handleDoScript" --
  503.  # 
  504.  #  The following routine handles the misc dosc event which your application
  505.  #  should support.  How you integrate it into your app depends largely on the
  506.  #  structure of said app.  I have installed it by adding a DoAppleEvent method
  507.  #  to my application subclass which checks each AppleEvent to see if it is
  508.  #  'misc' 'dosc'.  If so, this routine is called. CUSTOM */
  509.  # -------------------------------------------------------------------------
  510.  ##
  511. proc aeom::handleDoScript {theAppleEvent theReplyAE} {
  512.     set scriptDesc [tclAE::getKeyDesc $theAppleEvent ----]
  513.     set script [tclAE::getData $scriptDesc TEXT]
  514.     set type [tclAE::getDescType $scriptDesc]
  515.     tclAE::disposeDesc $scriptDesc
  516.     
  517.     switch -- $type {
  518.         "TEXT" {
  519.             eval $script
  520.         }
  521.         "alis" {
  522.             source $script
  523.         }
  524.         default {
  525.             set errn -1770
  526.             set errs "AEDoScriptHandler: invalid script type '${type}', \
  527.               must be 'alis' or 'TEXT'"
  528.             message $errs
  529.             
  530.             tclAE::putKeyData $theReplyAE errs TEXT $errs
  531.             tclAE::putKeyData $theReplyAE errn long $errn
  532.             
  533.             return $errn
  534.         }      
  535.     }
  536. }
  537.  
  538. proc aeom::constructAETE {} {
  539.     set suites {}
  540.     set events {}
  541.     set parameters {}
  542.     set enumerations {}
  543.     set enumerators {}
  544.     
  545.     lappend enumerators [list "yes" "yes " "take the action"]
  546.     lappend enumerators [list "no" "no  " "do not take the action"]
  547.     lappend enumerators [list "ask" "ask " "ask the user whether to take the action"]
  548.     
  549.     lappend enumerations [list savo $enumerators]
  550.     
  551.     lappend parameters [list "new window" NewW savo \
  552.       "whether to open file in a new window. (default: no)" 101]
  553.     lappend parameters [list "protecting bad line endings" perm savo \
  554.       "whether to allow saving a file with inconsistent line endings. \
  555.       (default: yes)" 101]
  556.     lappend parameters [list "wrapping" Wrap savo \
  557.       "whether to hard wrap the file. (default: no)" 101]
  558.     
  559.     lappend events [list "open" "open document" aevt odoc \
  560.       {null "" 000} {alis "the file to open" 0001} $parameters]
  561.     
  562.     lappend suites [list "Standard Suite" "Common terms for most applications" \
  563.       CoRe 1 1 $events {} {} $enumerations]
  564.     
  565.     
  566.     set events {}
  567.     set enumerations {}
  568.     set enumerators {}
  569.     
  570.     lappend enumerators [list "Tcl instructions" TEXT "Tcl script code to execute"]
  571.     lappend enumerators [list "alias" alis "alias of a .tcl script file to source"]
  572.     
  573.     lappend enumerations [list ScAl $enumerators]
  574.     
  575.     lappend events [list "do script" \
  576.       "Execute a Tcl (Tool Command Language) script" misc dosc \
  577.       {null "" 000} {ScAl "the Tcl script to execute" 0011}]
  578.     
  579.     lappend suites [list "Miscellaneous Standards Suite" \
  580.       "Useful events that aren’t in any other suite." \
  581.       misc 1 1 $events {} {} $enumerations]
  582.     
  583.     return [list 1 0 0 0 $suites]
  584. }
  585.  
  586. proc aeom::_extractPath {alis} {
  587.     switch [tclAE::subdesc::getType $alis] {
  588.         "obj " {
  589.             set alisDesc [tclAE::subdesc::toDesc $alis alis]
  590.         }
  591.         "alis" {
  592.             set alisDesc [tclAE::subdesc::toDesc $alis]
  593.         }
  594.     }
  595.     
  596.     set path [tclAE::getData $alisDesc TEXT]
  597.     
  598.     tclAE::disposeDesc $alisDesc    
  599.     
  600.     return $path
  601. }
  602.  
  603. proc aeom::_extractPaths {alises} {
  604.     
  605.     set paths {}
  606.     
  607.     switch -- [tclAE::subdesc::getType $alises] {
  608.         "list" {
  609.             set count [tclAE::countItems $alises]
  610.             
  611.             for {set item 0} {$item < $count} {incr item} {
  612.                 set alis [tclAE::subdesc::getNth $alises $item]
  613.                 
  614.                 lappend paths [aeom::_extractPath $alis]
  615.                 
  616.                 tclAE::subdesc::dispose $alis
  617.             }
  618.         }
  619.         default {
  620.             lappend paths [aeom::_extractPath $alises]
  621.         }
  622.     }
  623.     
  624.     return $paths
  625. }
  626.  
  627. # ◊◊◊◊ Object Accessors ◊◊◊◊ #
  628.  
  629. namespace eval aeom::accessor {}
  630.  
  631. proc aeom::accessor::registerAll {} {
  632.     tclAE::installObjectAccessor cwin null aeom::accessor::cwin<null
  633.     tclAE::installObjectAccessor cwor WIND aeom::accessor::cwor<WIND       
  634.     tclAE::installObjectAccessor cwor CHAR aeom::accessor::cwor<CHAR        
  635. }
  636.  
  637. # tclAE::resolve [tclAE::build::indexObject cwor 1 [tclAE::build::winByName aeom.tcl]]
  638.  
  639. proc aeom::accessor::cwin<null {desiredClass containerToken containerClass keyForm keyData theToken} {
  640.     set wins [winNames]
  641.     
  642.     switch -- $keyForm {
  643.         "name" {
  644.             set winNum [lsearch $wins [tclAE::getData $keyData TEXT]]
  645.             if {$winNum < 0} {
  646.                 error::throwOSErr –1728
  647.             } 
  648.         }
  649.         "indx" {
  650.             # absolute positions are 1-based
  651.             set winNum [expr {[tclAE::getData $keyData long] - 1}]
  652.             
  653.             if {($winNum >= [llength $wins]) || ($winNum < 0)} {
  654.                 error::throwOSErr –1728
  655.             }
  656.         }
  657.         default {
  658.             error::throwOSErr –1708
  659.         }
  660.     }
  661.     tclAE::replaceDescData $theToken WIND [lindex $wins $winNum]
  662. }
  663.  
  664. proc aeom::accessor::_cwor {win start stop keyForm keyData theToken} {
  665.     set mode [win::FindMode $win]
  666.     set wordBreak [mode::getVar wordBreak $mode]
  667.     set wordBreakPreface [mode::getVar wordBreakPreface $mode]
  668.     
  669.     switch -- $keyForm {
  670.       "indx" {
  671.         set index [tclAE::getData $keyData long]
  672.         if {$index > 0} {
  673.             # forward search from start of range
  674.             for {} {$index > 0} {incr index -1} {
  675.                 if {[catch {search -w $win -f 1 -r 1 -l $stop -- "$wordBreak" $start} word]} {
  676.                     # errAENoSuchObject
  677.                     error::throwOSErr -1728
  678.                 }
  679.                 set start [lindex $word 1]
  680.             }
  681.             set start [lindex $word 0]
  682.             set stop [lindex $word 1]
  683.         } else {
  684.             # backward search from end of range
  685.             for {} {$index < 0} {incr index} {
  686.                 if {[catch {search -w $win -f 0 -r 1 -l $start -- "$wordBreakPreface$wordBreak" [pos::math $stop - 1]} word]} {
  687.                     # errAENoSuchObject
  688.                     error::throwOSErr -1728
  689.                 }
  690.                 set stop [lindex $word 0]
  691.             }
  692.             set start [pos::math [lindex $word 0] + 1]
  693.             set stop [lindex $word 1]
  694.         }
  695.       }
  696.       "rang" {
  697.           set boundaries [aeom::accessor::_getBoundaries $keyData]
  698.           set startItem [lindex $boundaries 0]
  699.           set stopItem [lindex $boundaries 1]
  700.  
  701.           set startData [tclAE::getData $startItem TEXT]
  702.           if {[tclAE::getDescType $startItem] == "CHAR"} {
  703.               set start [lindex $startData 1]
  704.           } else {
  705.               set start [lindex $startData 2]
  706.           }
  707.           tclAE::disposeDesc $startItem
  708.           
  709.           set stopData [tclAE::getData $stopItem TEXT]
  710.           if {[tclAE::getDescType $stopItem] == "CHAR"} {
  711.               set stop [lindex $stopData 2]
  712.           } else {
  713.               set stop [lindex $stopData 1]
  714.           }
  715.           tclAE::disposeDesc $stopItem
  716.       }
  717.       "rele" {
  718.         
  719.       }
  720.       default {
  721.           error::throwOSErr –1708
  722.       }
  723.     }
  724.     
  725.     tclAE::replaceDescData $theToken CHAR [list $win $start $stop]
  726. }
  727.  
  728. proc aeom::accessor::_getBoundaries {rangeDesc} {
  729.     # is it really necessary to coerce this? gross
  730.     set rangeRecord [tclAE::coerceDesc $rangeDesc reco]
  731.  
  732.     set startDesc [tclAE::getKeyDesc $rangeRecord star]
  733.     set startItem [tclAE::resolve $startDesc]
  734.     tclAE::disposeDesc $startDesc
  735.  
  736.     set stopDesc [tclAE::getKeyDesc $rangeRecord stop]
  737.     set stopItem [tclAE::resolve $stopDesc]
  738.     tclAE::disposeDesc $stopDesc
  739.  
  740.     tclAE::disposeDesc $rangeRecord
  741.     
  742.     return [list $startItem $stopItem]
  743. }
  744.  
  745. proc aeom::accessor::cwor<WIND {desiredClass containerToken containerClass keyForm keyData theToken} {
  746.     set win [tclAE::getData $containerToken TEXT]
  747.     set start [minPos]
  748.     set stop [maxPos -w $win]
  749.     
  750.     aeom::accessor::_cwor $win $start $stop $keyForm $keyData $theToken
  751. }
  752.  
  753. proc aeom::accessor::cwor<CHAR {desiredClass containerToken containerClass keyForm keyData theToken} {
  754.     set charData [tclAE::getData $containerToken TEXT]
  755.     set win [lindex $charData 0]
  756.     set start [lindex $charData 1]
  757.     set stop [lindex $charData 2]
  758.     
  759.     aeom::accessor::_cwor $win $start $stop $keyForm $keyData $theToken
  760. }
  761.  
  762.  
  763.